;;; -*- mode: lisp -*-

(in-package "BS7")

;;;; URL and File System Roots.

(defvar *root-urlstring* "http://localhost:7654/")

(defvar *dojo-sources* "/Users/bhyde/w/dojo-0.3.1-ajax/")





;;;; Assembling Replies

;;; In this server all replies are fully computed before we
;;; generate any response headers.  This is good because if 
;;; something goes wrong  we can then send an error page.  This
;;; is bad because we don't acknowledge the request for a bit.

;;; In the dynamic extent created by handle-request we establish
;;; number of special variables into which we accumulate our
;;; response.  For example *expires?* defaults to nil but maybe
;;; set to the universal time at which the response should
;;; expire.   This is done via an :around method on the base
;;; server's handle-request method.

(defvar *assembly-active-p* nil)

(defparameter *default-css-parts*
  '((body 
     :border "1px solid #F1F1F1"
   ; :padding "4pt"
     :margin "1px"
     :background-color "#D9D9D9"
     :color "#261106")
    (.label :background "gray"
     :height "20px"
     :border-top "1px solid black"
     :border-bottom "1px solid black")
    (.content  :background-color "#D9D9D9")
    (p :padding "0.8pt" :margin "0.4pt")))

(defmacro within-reply-assembly-1 (() &body body)
  "Make use of specials lexically apparent."
  `(locally
    (declare (special 
	      *head-parts*
	      *dojo-requirements*
	      *css-parts*
	      *javascript-parts*
	      *body-parts* 
	      *expires?*))
    ,@body))

(defmacro within-reply-assembly (() &body body)
  `(progn
    (unless *assembly-active-p* (error "Not currently assembling a HTTP result."))
    (within-reply-assembly-1 ()
    ,@body)))

(defmacro with-reply-assembly (() &body body)
  `(let ((*assembly-active-p* t)
	  (*head-parts* nil)
	  (*dojo-requirements* nil)
	  (*css-parts* *default-css-parts*)
	  (*javascript-parts* nil)
	  (*body-parts* nil)
	  (*expires?* nil))
      (declare (special 
		*head-parts*
		*dojo-requirements*
		*css-parts*
		*javascript-parts*
		*body-parts* 
		*expires?*))
      ,@body))

(defmethod handle-request :around ((h handler) (r request))
  (with-reply-assembly ()
    (call-next-method h r)))

(defun note-dojo-requirement (library)
  (within-reply-assembly ()
    (pushnew library *dojo-requirements* :test #'string=)))

(defun note-javascript (javascript-sexpr)
  (within-reply-assembly ()
    (pushnew javascript-sexpr *javascript-parts* :test #'equal)))

(defun note-css (css-sexpr)
  (within-reply-assembly ()
    (pushnew css-sexpr *css-parts* :test #'equal)))

(defun note-expires (time-to-expire)
  (within-reply-assembly ()
    (setf *expires?* time-to-expire)))

(defun assemble-reply (stream)
  (within-reply-assembly ()
    (html-stream stream
		   `(html
		     (head
		      ,@(when *css-parts*
			      `((css ,@(nreverse *css-parts*))))
		      ,@(when *dojo-requirements*
			      `(((dojo-configuration :is-debug "true"))
				(dojo-bootstrap)
				(dojo-require
				 ,@(nreverse *dojo-requirements*))))
		      ,@(when *javascript-parts*
			      `((js-script
				 ,@(nreverse *javascript-parts*))))
		      ,@(nreverse *head-parts*))
		     (body 
		      ,@(nreverse *body-parts*))))))

(defun test-body-assembler (fun)
  (with-reply-assembly ()
    (push (funcall fun) *body-parts*)
    (assemble-reply *standard-output*)))

(defmethod request-send-headers :around ((r request) &rest args)
  (within-reply-assembly ()
    (apply #'call-next-method r :expires *expires?* args)))







;;;; A Simple Server

;;; URLS are series of tokens; by example http://localhost:7654/alpha/beta has
;;; two tokens; alpha and beta.  The tokens may only contain alphabetic
;;; characters.  The tokens must be symbol names enumerated in 
;;; *demo-test-page-list*.  *demo-test-page-list* is populated using
;;; def-test-page.  def-test-page creates functions; those functions are
;;; invoked when the page is generated in the order they appear in the url.
;;; These functions return HTML Sexpr which are assembled into the body
;;; of the resulting page.  

(defvar *demo-test-page-list* '()
  "A list of symbols, each has a function that will generate a HTML sexpr for demo.")

(defmacro def-test-page (name () &body body)
  `(progn
    (push ',name *demo-test-page-list*)
    (defun ,name () 
      (within-reply-assembly ()
	,@body))))

(defclass root-handler (handler)
  ((listener :accessor listener :initarg :listener)))

(defun parse-and-inteprete-path (url-path)
  (unless (every #'(lambda (c) (or (alpha-char-p c)
				   (member c '(#\- #\/)))) url-path)
    (error "Unacceptible URL"))
  (within-reply-assembly ()
    (flet ((tokenize-bit-or-error (string)
	     (let ((f (find string *demo-test-page-list* :test #'string-equal)))
	       (unless f
		 (error "Unknown URL token"))
	       f)))
      (loop for token
	in (loop for raw-bit in (split-sequence:split-sequence #\/ url-path)
		 collect (tokenize-bit-or-error raw-bit))
	as body-part? = (funcall token)
	when body-part? 
	do (push body-part? *body-parts*)))))



(defmethod handle-request-response ((h root-handler) (m (eql :get)) request)
  (cond
    ((string= "/" (url-path (request-url request)))
     (request-redirect request
		       (merge-url (root-url (listener h)) "home")))
    (t
     (within-reply-assembly ()
       (parse-and-inteprete-path (subseq (url-path (request-url request)) 1))
       (request-send-headers request)
       (assemble-reply (araneida:request-stream request))))))





;;;; The Listener & Install Handler

(defclass bs7-listener (#+:ARANEIDA-SERVE-EVENT serve-event-http-listener
			#+:ARANEIDA-THREADS threaded-http-listener
			#-(or :ARANEIDA-THREADS 
			      :ARANEIDA-SERVE-EVENT) (error "No araneida listener type?"))
  ((root-url :initarg :root-url :accessor root-url)))

(defmethod initialize-instance :after ((listener bs7-listener) &rest args)
  (declare (ignore args))
  (install-all-handlers listener))

(defvar *handle-installers* nil)

(defmacro define-handle-installer (name (listener) &body body)
  `(progn
    (defun ,name (,listener) ,@body)
    (pushnew ',name *handle-installers*)))

(defmacro define-handler-for-static-files-of-system
    (&key (relative-url-path "/static/")
	  (system-name
	   (intern (package-name *package*) (symbol-package :key)))
	  (relative-pathname "static/"))
  (let ((name (intern (format nil "STATIC-HANDLER-FOR-SYSTEM-~A" system-name))))
  `(define-handle-installer ,name (listener)
    (install-handler (http-listener-handler listener)
		     (make-instance 'static-for-a-week-file-handler
				  :pathname 
				  (merge-pathnames
				   ,relative-pathname
				   (slot-value
				    (asdf:find-system ',system-name)
				    'asdf::relative-pathname)))
		   (urlstring (merge-url (root-url listener) ,relative-url-path))
		   nil))))

(defgeneric install-all-handlers (bs7-listener))

(defmethod install-all-handlers ((listener bs7-listener))
  (loop for handle-installer in *handle-installers*
	do (funcall handle-installer listener)))

(define-handle-installer install-default-handler (listener)
    (install-handler (http-listener-handler listener)
		     (make-instance 'root-handler
				    :listener listener)
		     (urlstring (merge-url (root-url listener) "/"))
		     nil))

(setf *dojo-bootstrap-pathname* "/s/dojo.js")

(defvar *dojo-bootstrap-url?*
      "http://o.aolcdn.com/iamalpha/.resource/jssdk/dojo-0.3.1/dojo.js")

(defclass static-for-a-week-file-handler (static-file-handler) ())

(defmethod handle-request-response :around ((handler static-file-handler) method request)
  (within-reply-assembly ()
    (note-expires (+ (get-universal-time) #.(* 60 60 24 7)))
    (call-next-method handler method request)))



(define-handle-installer install-dojo-javascript-files (listener)
  (install-handler (http-listener-handler listener)
		   (make-instance 'static-for-a-week-file-handler
				  :pathname (pathname *dojo-sources*))
		   (urlstring (merge-url (root-url listener) "/s/"))
		   nil))

(defclass handler-sending-error (handler)
  ((error-number :initarg :error-number)))

(defmethod handle-request-response ((handler handler-sending-error) method request)
  (declare (ignore method))
  (request-send-error request (slot-value handler 'error-number)))

(define-handle-installer install-favicon (listener)
  (install-handler (http-listener-handler listener)
		   (make-instance 'handler-sending-error
				  :error-number 404)
		   (urlstring (merge-url (root-url listener) "/favicon.ico"))
		   T))


(defvar *listener* nil)

(defun start-server (&optional (root-urlstring *root-urlstring*))
  (stop-server)
  (setf *root-urlstring* root-urlstring)
  (let ((root (parse-urlstring *root-urlstring*)))
    (setf *listener* (make-instance
		      'bs7-listener
		      :port (araneida:url-port root)
		      :root-url root)))
  (start-listening *listener*))

(defun stop-server ()
  (when (and *listener*
	     (slot-value *listener* 'araneida::socket))
    (stop-listening *listener*))
  (setf *listener* nil))




;;; Logging and Debugging

;; via http://paste.lisp.org/display/1322
(setf araneida:*restart-on-handler-errors*
  (lambda (foo)
     (swank:swank-debugger-hook foo nil)))

(defmethod handle-request-authentication ((handler handler) method request )
  (format araneida::*log-stream* 
	  "~&(:stage :auth :method ~S :method ~S :via ~S)"
	  method
	  (urlstring (request-url request))
	  (type-of handler))
  t)

(defmethod handle-request-logging ((handler handler) method request )
  (format araneida::*log-stream* 
	  "~&(:stage :log :method ~S :method ~S :via ~S)"
	  method
	  (urlstring (request-url request))
	  (type-of handler))
  t)

#+nil
(defmethod handle-request-logging (handler method request)
  (declare (ignore handler method))
  (describe request araneida::*log-stream*))


